home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / lib / perl5 / HTML / HeadParser.pm < prev    next >
Text File  |  2005-09-12  |  7KB  |  260 lines
  1. package HTML::HeadParser;
  2.  
  3. =head1 NAME
  4.  
  5. HTML::HeadParser - Parse <HEAD> section of a HTML document
  6.  
  7. =head1 SYNOPSIS
  8.  
  9.  require HTML::HeadParser;
  10.  $p = HTML::HeadParser->new;
  11.  $p->parse($text) and  print "not finished";
  12.  
  13.  $p->header('Title')          # to access <title>....</title>
  14.  $p->header('Content-Base')   # to access <base href="http://...">
  15.  $p->header('Foo')            # to access <meta http-equiv="Foo" content="...">
  16.  
  17. =head1 DESCRIPTION
  18.  
  19. The C<HTML::HeadParser> is a specialized (and lightweight)
  20. C<HTML::Parser> that will only parse the E<lt>HEAD>...E<lt>/HEAD>
  21. section of an HTML document.  The parse() method
  22. will return a FALSE value as soon as some E<lt>BODY> element or body
  23. text are found, and should not be called again after this.
  24.  
  25. Note that the C<HTML::HeadParser> might get confused if raw undecoded
  26. UTF-8 is passed to the parse() method.  Make sure the strings are
  27. properly decoded before passing them on.
  28.  
  29. The C<HTML::HeadParser> keeps a reference to a header object, and the
  30. parser will update this header object as the various elements of the
  31. E<lt>HEAD> section of the HTML document are recognized.  The following
  32. header fields are affected:
  33.  
  34. =over 4
  35.  
  36. =item Content-Base:
  37.  
  38. The I<Content-Base> header is initialized from the E<lt>base
  39. href="..."> element.
  40.  
  41. =item Title:
  42.  
  43. The I<Title> header is initialized from the E<lt>title>...E<lt>/title>
  44. element.
  45.  
  46. =item Isindex:
  47.  
  48. The I<Isindex> header will be added if there is a E<lt>isindex>
  49. element in the E<lt>head>.  The header value is initialized from the
  50. I<prompt> attribute if it is present.  If no I<prompt> attribute is
  51. given it will have '?' as the value.
  52.  
  53. =item X-Meta-Foo:
  54.  
  55. All E<lt>meta> elements will initialize headers with the prefix
  56. "C<X-Meta->" on the name.  If the E<lt>meta> element contains a
  57. C<http-equiv> attribute, then it will be honored as the header name.
  58.  
  59. =back
  60.  
  61. =head1 METHODS
  62.  
  63. The following methods (in addition to those provided by the
  64. superclass) are available:
  65.  
  66. =over 4
  67.  
  68. =cut
  69.  
  70.  
  71. require HTML::Parser;
  72. @ISA = qw(HTML::Parser);
  73.  
  74. use HTML::Entities ();
  75.  
  76. use strict;
  77. use vars qw($VERSION $DEBUG);
  78. #$DEBUG = 1;
  79. $VERSION = sprintf("%d.%02d", q$Revision: 2.22 $ =~ /(\d+)\.(\d+)/);
  80.  
  81. =item $hp = HTML::HeadParser->new
  82.  
  83. =item $hp = HTML::HeadParser->new( $header )
  84.  
  85. The object constructor.  The optional $header argument should be a
  86. reference to an object that implement the header() and push_header()
  87. methods as defined by the C<HTTP::Headers> class.  Normally it will be
  88. of some class that isa or delegates to the C<HTTP::Headers> class.
  89.  
  90. If no $header is given C<HTML::HeadParser> will create an
  91. C<HTTP::Header> object by itself (initially empty).
  92.  
  93. =cut
  94.  
  95. sub new
  96. {
  97.     my($class, $header) = @_;
  98.     unless ($header) {
  99.     require HTTP::Headers;
  100.     $header = HTTP::Headers->new;
  101.     }
  102.  
  103.     my $self = $class->SUPER::new(api_version => 2,
  104.                   ignore_elements => [qw(script style)],
  105.                  );
  106.     $self->{'header'} = $header;
  107.     $self->{'tag'} = '';   # name of active element that takes textual content
  108.     $self->{'text'} = '';  # the accumulated text associated with the element
  109.     $self;
  110. }
  111.  
  112. =item $hp->header;
  113.  
  114. Returns a reference to the header object.
  115.  
  116. =item $hp->header( $key )
  117.  
  118. Returns a header value.  It is just a shorter way to write
  119. C<$hp-E<gt>header-E<gt>header($key)>.
  120.  
  121. =cut
  122.  
  123. sub header
  124. {
  125.     my $self = shift;
  126.     return $self->{'header'} unless @_;
  127.     $self->{'header'}->header(@_);
  128. }
  129.  
  130. sub as_string    # legacy
  131. {
  132.     my $self = shift;
  133.     $self->{'header'}->as_string;
  134. }
  135.  
  136. sub flush_text   # internal
  137. {
  138.     my $self = shift;
  139.     my $tag  = $self->{'tag'};
  140.     my $text = $self->{'text'};
  141.     $text =~ s/^\s+//;
  142.     $text =~ s/\s+$//;
  143.     $text =~ s/\s+/ /g;
  144.     print "FLUSH $tag => '$text'\n"  if $DEBUG;
  145.     if ($tag eq 'title') {
  146.     HTML::Entities::decode($text);
  147.     $self->{'header'}->push_header(Title => $text);
  148.     }
  149.     $self->{'tag'} = $self->{'text'} = '';
  150. }
  151.  
  152. # This is an quote from the HTML3.2 DTD which shows which elements
  153. # that might be present in a <HEAD>...</HEAD>.  Also note that the
  154. # <HEAD> tags themselves might be missing:
  155. #
  156. # <!ENTITY % head.content "TITLE & ISINDEX? & BASE? & STYLE? &
  157. #                            SCRIPT* & META* & LINK*">
  158. #
  159. # <!ELEMENT HEAD O O  (%head.content)>
  160.  
  161.  
  162. sub start
  163. {
  164.     my($self, $tag, $attr) = @_;  # $attr is reference to a HASH
  165.     print "START[$tag]\n" if $DEBUG;
  166.     $self->flush_text if $self->{'tag'};
  167.     if ($tag eq 'meta') {
  168.     my $key = $attr->{'http-equiv'};
  169.     if (!defined($key) || !length($key)) {
  170.         return unless $attr->{'name'};
  171.         $key = "X-Meta-\u$attr->{'name'}";
  172.     }
  173.     $self->{'header'}->push_header($key => $attr->{content});
  174.     } elsif ($tag eq 'base') {
  175.     return unless exists $attr->{href};
  176.     $self->{'header'}->push_header('Content-Base' => $attr->{href});
  177.     } elsif ($tag eq 'isindex') {
  178.     # This is a non-standard header.  Perhaps we should just ignore
  179.     # this element
  180.     $self->{'header'}->push_header(Isindex => $attr->{prompt} || '?');
  181.     } elsif ($tag =~ /^(?:title|script|style)$/) {
  182.     # Just remember tag.  Initialize header when we see the end tag.
  183.     $self->{'tag'} = $tag;
  184.     } elsif ($tag eq 'link') {
  185.     return unless exists $attr->{href};
  186.     # <link href="http:..." rel="xxx" rev="xxx" title="xxx">
  187.     my $h_val = "<" . delete($attr->{href}) . ">";
  188.     for (sort keys %{$attr}) {
  189.         $h_val .= qq(; $_="$attr->{$_}");
  190.     }
  191.     $self->{'header'}->push_header(Link => $h_val);
  192.     } elsif ($tag eq 'head' || $tag eq 'html') {
  193.     # ignore
  194.     } else {
  195.      # stop parsing
  196.     $self->eof;
  197.     }
  198. }
  199.  
  200. sub end
  201. {
  202.     my($self, $tag) = @_;
  203.     print "END[$tag]\n" if $DEBUG;
  204.     $self->flush_text if $self->{'tag'};
  205.     $self->eof if $tag eq 'head';
  206. }
  207.  
  208. sub text
  209. {
  210.     my($self, $text) = @_;
  211.     $text =~ s/\x{FEFF}//;  # drop Unicode BOM if found
  212.     print "TEXT[$text]\n" if $DEBUG;
  213.     my $tag = $self->{tag};
  214.     if (!$tag && $text =~ /\S/) {
  215.     # Normal text means start of body
  216.         $self->eof;
  217.     return;
  218.     }
  219.     return if $tag ne 'title';
  220.     $self->{'text'} .= $text;
  221. }
  222.  
  223. 1;
  224.  
  225. __END__
  226.  
  227. =back
  228.  
  229. =head1 EXAMPLE
  230.  
  231.  $h = HTTP::Headers->new;
  232.  $p = HTML::HeadParser->new($h);
  233.  $p->parse(<<EOT);
  234.  <title>Stupid example</title>
  235.  <base href="http://www.linpro.no/lwp/">
  236.  Normal text starts here.
  237.  EOT
  238.  undef $p;
  239.  print $h->title;   # should print "Stupid example"
  240.  
  241. =head1 SEE ALSO
  242.  
  243. L<HTML::Parser>, L<HTTP::Headers>
  244.  
  245. The C<HTTP::Headers> class is distributed as part of the
  246. I<libwww-perl> package.  If you don't have that distribution installed
  247. you need to provide the $header argument to the C<HTML::HeadParser>
  248. constructor with your own object that implements the documented
  249. protocol.
  250.  
  251. =head1 COPYRIGHT
  252.  
  253. Copyright 1996-2001 Gisle Aas. All rights reserved.
  254.  
  255. This library is free software; you can redistribute it and/or
  256. modify it under the same terms as Perl itself.
  257.  
  258. =cut
  259.  
  260.